home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / struct.scm < prev    next >
Text File  |  1999-04-19  |  5KB  |  166 lines
  1. ;;; "struct.scm": defmacros for RECORDS
  2. ;;; Copyright 1992 Jeff Alexander, Shinnder Lee, and Lewis Patterson
  3.  
  4. ;;; Defmacros which implement RECORDS from the book:
  5. ;;; "Essentials of Programming Languages" by Daniel P. Friedman,
  6. ;;;   M. Wand and C.T. Haynes.
  7.  
  8. ;;; jaffer@ai.mit.edu, Feb 1993 ported to SLIB.
  9.  
  10. ;;;  Date: Sun, 20 Aug 1995 19:20:35 -0500
  11. ;;;  From: Gary Leavens <leavens@cs.iastate.edu>
  12. ;;; I thought you might want to know that, for using the file
  13. ;;; struct.scm with the EOPL book, one has to make 2 corrections.  To
  14. ;;; correct it, there are two places where "-" has to be replaced by
  15. ;;; "->" as in the code below.
  16.  
  17. (require 'common-list-functions)
  18.  
  19. (defmacro define-record args
  20.   (check-define-record-syntax args
  21.     (lambda (name make-name name? field-accessors field-setters)
  22.       (letrec
  23.     ((make-fields
  24.        (lambda (field-accessors i)
  25.          (if (null? field-accessors)
  26.            '()
  27.            (cons
  28.          `(define ,(car field-accessors)
  29.             (lambda (obj)
  30.               (if (,name? obj)
  31.             (vector-ref obj ,i)
  32.             (slib:error ',(car field-accessors)
  33.               ": bad record" obj))))
  34.          (make-fields (cdr field-accessors) (+ i 1))))))
  35.      (make-setters
  36.       (lambda (field-accessors i)
  37.         (if (null? field-accessors)
  38.         '()
  39.         (cons
  40.          `(define ,(car field-accessors)
  41.             (lambda (obj val)
  42.               (if (,name? obj)
  43.               (vector-set! obj ,i val)
  44.               (slib:error ',(car field-accessors)
  45.                       ": bad record" obj))))
  46.          (make-setters (cdr field-accessors) (+ i 1)))))))
  47.      `(begin
  48.        ,@(make-fields field-accessors 1)
  49.        ,@(make-setters field-setters 1)
  50.        (define ,name?
  51.          (lambda (obj)
  52.            (and (vector? obj)
  53.          (= (vector-length obj) ,(+ 1 (length field-accessors)))
  54.          (eq? (vector-ref obj 0) ',name))))
  55.        (define ,make-name
  56.          (lambda ,field-accessors
  57.            (vector ',name ,@field-accessors))))))))
  58.  
  59. (defmacro variant-case args
  60.   (check-variant-case-syntax args
  61.     (lambda (exp clauses)
  62.       (let ((var (gentemp)))
  63.     (let
  64.       ((make-clause
  65.          (lambda (clause)
  66.            (if (eq? (car clause) 'else)
  67.          `(#t ,@(cdr clause))
  68.          `((,(car clause) ,var)
  69.            (let ,(map (lambda (field)
  70.                 `(,(car field) (,(cdr field) ,var)))
  71.                (cadr clause))
  72.              ,@(cddr clause)))))))
  73.       `(let ((,var ,exp))
  74.          (cond ,@(map make-clause clauses))))))))
  75.  
  76. ;;; syntax checkers
  77.  
  78. ;;; name make-name name? field-accessors
  79.  
  80. (define check-define-record-syntax
  81.   (lambda (x k)
  82.       (cond
  83.     ((and (list? x)
  84.        (= (length x) 2)
  85.        (symbol? (car x))
  86.        (list? (cadr x))
  87.        (comlist:every symbol? (cadr x))
  88.        (not (struct:duplicate-fields? (cadr x))))
  89.      (let ((name (symbol->string (car x))))
  90.        (let ((make-name (string->symbol
  91.                   (string-append (symbol->string 'make-) name)))
  92.          (name? (string->symbol (string-append name "?")))
  93.          (field-accessors
  94.            (map
  95.              (lambda (field)
  96.                (string->symbol
  97.              (string-append name "->" (symbol->string field))))
  98.              (cadr x)))
  99.          (field-setters
  100.           (map
  101.            (lambda (field)
  102.              (string->symbol
  103.               (string-append 
  104.                "set-" name "-" (symbol->string field) "!")))
  105.            (cadr x))))
  106.          (k (car x) make-name name? field-accessors field-setters))))
  107.     (else (slib:error "define-record: invalid syntax" x)))))
  108.        
  109. (define check-variant-case-syntax
  110.   (let
  111.     ((make-clause
  112.        (lambda (clause)
  113.      (if (eq? (car clause) 'else) 
  114.        clause
  115.        (let ((name (symbol->string (car clause))))
  116.          (let ((name? (string->symbol (string-append name "?")))
  117.            (fields
  118.              (map
  119.                (lambda (field)
  120.              (cons field
  121.                (string->symbol
  122.                  (string-append name "->"
  123.                    (symbol->string field)))))
  124.                (cadr clause))))
  125.            (cons name? (cons fields (cddr clause)))))))))
  126.     (lambda (args k)
  127.       (if (and (list? args)
  128.         (<= 2 (length args))
  129.         (struct:clauses? (cdr args)))
  130.     (k (car args) (map make-clause (cdr args)))
  131.     (slib:error "variant-case: invalid syntax" args)))))
  132.  
  133. (define struct:duplicate-fields?
  134.   (lambda (fields)
  135.     (cond
  136.       ((null? fields) #f)
  137.       ((memq (car fields) (cdr fields)) #t)
  138.       (else (struct:duplicate-fields? (cdr fields))))))
  139.  
  140. (define struct:clauses?
  141.   (let
  142.     ((clause?
  143.        (lambda (clause)
  144.      (and (list? clause)
  145.           (not (null? clause))
  146.           (cond
  147.         ((eq? (car clause) 'else)
  148.          (not (null? (cdr clause))))
  149.         (else (and (symbol? (car clause))
  150.                (not (null? (cdr clause)))
  151.                (list? (cadr clause))
  152.                (comlist:every symbol? (cadr clause))
  153.                (not (struct:duplicate-fields? (cadr clause)))
  154.                (not (null? (cddr clause))))))))))
  155.     (letrec
  156.       ((struct:duplicate-tags?
  157.      (lambda (tags)
  158.        (cond
  159.          ((null? tags) #f)
  160.          ((eq? (car tags) 'else) (not (null? (cdr tags))))
  161.          ((memq (car tags) (cdr tags)) #t)
  162.          (else (struct:duplicate-tags? (cdr tags)))))))
  163.       (lambda (clauses)
  164.     (and (comlist:every clause? clauses)
  165.          (not (struct:duplicate-tags? (map car clauses))))))))
  166.